home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / scs.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  2.3 KB  |  61 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module scs)
  13.  
  14. (DECLARE-TOP (*EXPR $RATSUBST CONSSIZE))
  15.  
  16. (DEFMFUN $SCSIMP N 
  17.   (DO ((I N (f1- I)) (ZRS)) ((= 1 I) (SCS (ARG 1) ZRS))
  18.       (SETQ ZRS (CONS (IFN (EQ 'MEQUAL (CAAR (ARG I))) (ARG I)
  19.                (SUB (CADR (ARG I)) (CADDR (ARG I)))) ZRS))))
  20.  
  21. (DEFUN SCS (X ZRS)
  22.   (DO ((FLAG T) (SZ (CONSSIZE X)) (NX) (NSZ)) ((NOT FLAG) X)
  23.       (DO ((L ZRS (CDR L))) ((NULL L) (SETQ FLAG NIL))
  24.       (SETQ NX (SUBSCS 0 (CAR L) X) NSZ (CONSSIZE NX))
  25.       (IF (< NSZ SZ) (RETURN (SETQ X NX SZ NSZ))))))
  26.  
  27. (DEFUN SUBSCS (A B C)
  28.   (COND ((ATOM B) (SUBSC A B C))
  29.     ((EQ 'MPLUS (CAAR B))
  30.      (DO ((L (CDR B) (CDR L)) (SZ (CONSSIZE C)) (NL) (NC) (NSZ)) ((NULL L) C)
  31.          (SETQ NC (SUBSCS (SUB A (ADDN (RECONC NL (CDR L)) T)) (CAR L) C)
  32.            NSZ (CONSSIZE NC) NL (CONS (CAR L) NL))
  33.          (IF (< NSZ SZ) (SETQ C NC SZ NSZ))))
  34.     (T (SUBSC A B C))))
  35.  
  36. (DEFUN SUBSC (A B C) ($EXPAND ($RATSUBST A B C)))
  37.  
  38. (DEFMFUN $DISTRIB (EXP)
  39.   (COND ((OR (MNUMP EXP) (SYMBOLP EXP)) EXP)
  40.     ((EQ 'MTIMES (CAAR EXP))
  41.      (SETQ EXP (MAPCAR '$DISTRIB (CDR EXP)))
  42.      (DO ((L (CDR EXP) (CDR L))
  43.           (NL (IF (MPLUSP (CAR EXP)) (CDAR EXP) (LIST (CAR EXP)))))
  44.          ((NULL L) (ADDN NL T))
  45.          (IF (MPLUSP (CAR L))
  46.          (DO ((M (CDAR L) (CDR M)) (ML)) ((NULL M) (SETQ NL ML))
  47.              (SETQ ML (DSTRB (CAR M) NL ML)))
  48.          (SETQ NL (DSTRB (CAR L) NL NIL)))))
  49.     ((EQ 'MEQUAL (CAAR EXP))
  50.      (LIST '(MEQUAL) ($DISTRIB (CADR EXP)) ($DISTRIB (CADDR EXP))))
  51.     ((EQ 'MRAT (CAAR EXP)) ($DISTRIB (RATDISREP EXP)))
  52.     (T EXP)))
  53.  
  54. (DEFUN DSTRB (X L NL)
  55.   (DO () ((NULL L) NL)
  56.       (SETQ NL (CONS (MUL X (CAR L)) NL) L (CDR L))))
  57.  
  58. (DEFMFUN $FACOUT (X Y)
  59.   (IFN (EQ 'MPLUS (CAAR Y)) Y
  60.        (MUL X (ADDN (MAPCAR #'(LAMBDA (L) (DIV L X)) (CDR Y)) T))))
  61.